home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / tty.scm < prev    next >
Text File  |  1995-10-31  |  13KB  |  365 lines
  1. ;;; My comments:
  2. ;;; - We have a lot of NeXT-specific stuff. More importantly, what is the
  3. ;;;   Linux, Solaris, and HP-UX specific stuff?
  4. ;;;
  5. ;;; - I would suggest totally flushing the ttychars vector from the interface
  6. ;;;   in favor of individual slots in the TTY-INFO record. Keep the vec
  7. ;;;   in the implementation, and define the TTY-INFO:EOL, etc. procs by
  8. ;;;   hand as being indices into the vector. We could *also* expose the
  9. ;;;   vector if we liked.
  10. ;;;     -Olin
  11.  
  12. ;;; Terminal Control for the Scheme Shell
  13. ;;; Copyright (c) 1995 by Brian D. Carlstrom.
  14. ;;; Rehacked by Olin 8/95.
  15.  
  16. (foreign-source
  17.  "#include <sys/types.h>"
  18.  ""
  19.  "#include <unistd.h>"
  20.  "#include <termios.h>"
  21.  ""
  22.  "/* Make sure foreign-function stubs interface to the C funs correctly: */"
  23.  "#include \"tty1.h\""
  24.  ""
  25.  "extern int errno;"
  26.  ""
  27.  "#define errno_or_false(x) (((x) == -1) ? ENTER_FIXNUM(errno) : SCHFALSE)"
  28.  "" )
  29.  
  30.  
  31. ;;; tty-info records
  32. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  33. ;;; I have to fake out my record package so I can define my very own
  34. ;;; MAKE-TTY-INFO procedure. Ech. I oughta have a lower-level record macro
  35. ;;; for this kind of thing.
  36.  
  37. (define-record %tty-info
  38.   control-chars
  39.   input-flags
  40.   output-flags
  41.   control-flags
  42.   local-flags
  43.   input-speed
  44.   input-speed-code
  45.   output-speed
  46.   output-speed-code
  47.   min
  48.   time
  49.   ((disclose info) '("tty-info")))
  50.  
  51. (define tty-info?    %tty-info?)
  52. (define type/tty-info    type/%tty-info)
  53.  
  54. (define tty-info:control-chars     %tty-info:control-chars)
  55. (define tty-info:input-flags     %tty-info:input-flags)
  56. (define tty-info:output-flags     %tty-info:output-flags)
  57. (define tty-info:control-flags     %tty-info:control-flags)
  58. (define tty-info:local-flags     %tty-info:local-flags)
  59. (define tty-info:input-speed     %tty-info:input-speed)
  60. (define tty-info:output-speed     %tty-info:output-speed)
  61. (define tty-info:min         %tty-info:min)
  62. (define tty-info:time         %tty-info:time)
  63.  
  64. (define set-tty-info:control-chars     set-%tty-info:control-chars)
  65. (define set-tty-info:input-flags     set-%tty-info:input-flags)
  66. (define set-tty-info:output-flags     set-%tty-info:output-flags)
  67. (define set-tty-info:control-flags     set-%tty-info:control-flags)
  68. (define set-tty-info:local-flags     set-%tty-info:local-flags)
  69. (define set-tty-info:min         set-%tty-info:min)
  70. (define set-tty-info:time         set-%tty-info:time)
  71.  
  72. ;;; Encode the speeds at assignment time.
  73. (define (set-tty-info:input-speed info speed)
  74.   (set-%tty-info:input-speed-code info (encode-baud-rate speed))
  75.   (set-%tty-info:input-speed      info speed))
  76.  
  77. (define (set-tty-info:output-speed info speed)
  78.   (set-%tty-info:output-speed-code info (encode-baud-rate speed))
  79.   (set-%tty-info:output-speed      info speed))
  80.  
  81.  
  82. (define (make-tty-info iflags oflags cflags lflags ispeed ospeed min time)
  83.   (make-%tty-info (make-string num-ttychars (ascii->char 0))
  84.           iflags oflags cflags lflags
  85.           ispeed (encode-baud-rate ispeed)
  86.           ospeed (encode-baud-rate ospeed)
  87.           min time))
  88.  
  89. (define (copy-tty-info info)
  90.   (make-%tty-info (string-copy (tty-info:control-chars info))
  91.           (tty-info:input-flags           info)
  92.           (tty-info:output-flags       info)
  93.           (tty-info:control-flags      info)
  94.           (tty-info:local-flags           info)
  95.           (tty-info:input-speed           info)
  96.           (%tty-info:input-speed-code  info)
  97.           (tty-info:output-speed       info)
  98.           (%tty-info:output-speed-code info)
  99.           (tty-info:min               info)
  100.           (tty-info:time           info)))
  101.           
  102.  
  103. ;;; (tty-info fd/port)
  104. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  105. ;;; Retrieve tty-info bits from a tty.
  106.  
  107. (define (tty-info fdport)
  108.   (let ((control-chars (make-string num-ttychars)))
  109.     (receive (iflag-hi8 iflag-lo24 oflag-hi8 oflag-lo24
  110.           cflag-hi8 cflag-lo24 lflag-hi8 lflag-lo24
  111.           ispeed-code ospeed-code)
  112.     (call/fdes fdport (lambda (fd) (%tty-info fd control-chars)))
  113.       (make-%tty-info control-chars
  114.               (bitwise-ior (arithmetic-shift iflag-hi8 24) iflag-lo24)
  115.               (bitwise-ior (arithmetic-shift oflag-hi8 24) oflag-lo24)
  116.               (bitwise-ior (arithmetic-shift cflag-hi8 24) cflag-lo24)
  117.               (bitwise-ior (arithmetic-shift lflag-hi8 24) lflag-lo24)
  118.               (decode-baud-rate ispeed-code) ispeed-code
  119.               (decode-baud-rate ospeed-code) ospeed-code
  120.               (char->ascii (string-ref control-chars ttychar/min))
  121.               (char->ascii (string-ref control-chars ttychar/time))))))
  122.  
  123. (define-errno-syscall (%tty-info fdes control-chars) %tty-info/errno
  124.   iflag-hi8 iflag-lo24
  125.   oflag-hi8 oflag-lo24
  126.   cflag-hi8 cflag-lo24
  127.   lflag-hi8 lflag-lo24
  128.   ispeed-code ospeed-code)
  129.  
  130. (define-foreign %tty-info/errno
  131.   (scheme_tcgetattr (integer fdes)
  132.             (var-string control-chars))
  133.   (to-scheme integer errno_or_false)
  134.   integer integer
  135.   integer integer
  136.   integer integer
  137.   integer integer
  138.   integer integer)
  139.  
  140.  
  141. ;;; (set-tty-info       fdport option info)    [Not exported]
  142. ;;; (set-tty-info/now   fdport option info)
  143. ;;; (set-tty-info/drain fdport option info)
  144. ;;; (set-tty-info/flush fdport option info)
  145. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  146. ;;; Assign tty-info bits to a tty.
  147.  
  148. (define (set-tty-info fdport option info)
  149.   (let ((if (tty-info:input-flags   info))
  150.     (of (tty-info:output-flags  info))
  151.     (cf (tty-info:control-flags info))
  152.     (lf (tty-info:local-flags   info))
  153.     (cc (tty-info:control-chars info))
  154.     (is (%tty-info:input-speed-code  info))
  155.     (os (%tty-info:output-speed-code info)))
  156.     (let ((iflag-hi8  (arithmetic-shift if -24))
  157.       (iflag-lo24 (bitwise-and if #xffffff))
  158.       (oflag-hi8  (arithmetic-shift of -24))
  159.       (oflag-lo24 (bitwise-and of #xffffff))
  160.       (cflag-hi8  (arithmetic-shift cf -24))
  161.       (cflag-lo24 (bitwise-and cf #xffffff))
  162.       (lflag-hi8  (arithmetic-shift lf -24))
  163.       (lflag-lo24 (bitwise-and lf #xffffff)))
  164.       (call/fdes fdport
  165.         (lambda (fd)
  166.       (%set-tty-info fd option
  167.              cc
  168.              iflag-hi8 iflag-lo24
  169.              oflag-hi8 oflag-lo24
  170.              cflag-hi8 cflag-lo24
  171.              lflag-hi8 lflag-lo24
  172.              is        os
  173.              (tty-info:min  info)
  174.              (tty-info:time info)))))))
  175.  
  176.  
  177. (define-simple-errno-syscall (%set-tty-info fdes      option
  178.                         control-chars
  179.                         iflag-hi8 iflag-lo24
  180.                         oflag-hi8 oflag-lo24
  181.                         cflag-hi8 cflag-lo24
  182.                         lflag-hi8 lflag-lo24
  183.                         ispeed-code ospeed-code
  184.                         min          time)
  185.   %set-tty-info/errno)
  186.  
  187.  
  188. (define-foreign %set-tty-info/errno
  189.   (scheme_tcsetattr (integer fdes)
  190.             (integer option)
  191.             (string  control-chars)
  192.             (integer iflag-hi8)
  193.             (integer iflag-lo24)
  194.             (integer oflag-hi8) 
  195.             (integer oflag-lo24)
  196.             (integer cflag-hi8) 
  197.             (integer cflag-lo24)
  198.             (integer lflag-hi8) 
  199.             (integer lflag-lo24)
  200.             (integer ispeed-code) 
  201.             (integer ospeed-code)
  202.             (integer min)
  203.             (integer time))
  204.   (to-scheme integer errno_or_false))
  205.  
  206.  
  207. ;;; Exported procs
  208. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  209. ;;; Note that the magic %set-tty-info/foo constants must be defined before this
  210. ;;; file is loaded due to the set-tty-info/foo definitions below.
  211.  
  212. (define (make-tty-info-setter how)
  213.   (lambda (fdport info) (set-tty-info fdport how info)))
  214.  
  215. (define set-tty-info/now   (make-tty-info-setter %set-tty-info/now))
  216. (define set-tty-info/drain (make-tty-info-setter %set-tty-info/drain))
  217. (define set-tty-info/flush (make-tty-info-setter %set-tty-info/flush))
  218.  
  219.  
  220. ;;; Send a break on the serial line.
  221. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  222.  
  223. (define (send-tty-break fdport . maybe-duration)
  224.   (call/fdes fdport
  225.     (lambda (fdes)
  226.       (%send-tty-break-fdes fdes (optional-arg maybe-duration 0)))))
  227.  
  228. (define-errno-syscall (%send-tty-break-fdes fdes duration)
  229.   %send-tty-break-fdes/errno)
  230.  
  231. (define-foreign %send-tty-break-fdes/errno
  232.   (tcsendbreak (integer fdes) (integer duration))
  233.   (to-scheme integer errno_or_false))
  234.  
  235.  
  236. ;;; Drain the main vein.
  237. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  238.  
  239. (define (drain-tty fdport)
  240.   (cond ((integer? fdport) (%tcdrain fdport))    ; File descriptor.
  241.     ((fdport? fdport)            ; Scheme port -- flush first.
  242.      (force-output fdport)
  243.      (call/fdes fdport %tcdrain))
  244.     (else (error "Illegal argument to DRAIN-TTY" fdport))))
  245.  
  246. (define-errno-syscall (%tcdrain fdes) %tcdrain/errno)
  247. (define-foreign %tcdrain/errno (tcdrain (integer fdes)) no-declare ; Ultrix
  248.   (to-scheme integer errno_or_false))
  249.  
  250.  
  251. ;;; Flushing the device queues. (tcflush)
  252. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  253. ;;; Note that the magic %flush-tty/foo constants must be defined before this
  254. ;;; file is loaded due to the flush-tty/foo definitions below.
  255.  
  256. (define (make-tty-flusher flag)
  257.   (lambda (fdport)
  258.     (call/fdes fdport (lambda (fdes) (%tcflush fdes flag)))))
  259.  
  260. (define flush-tty/input  (make-tty-flusher %flush-tty/input))
  261. (define flush-tty/output (make-tty-flusher %flush-tty/output))
  262. (define flush-tty/both   (make-tty-flusher %flush-tty/both))
  263.  
  264. (define-errno-syscall (%tcflush fdes flag) %tcflush/errno)
  265. (define-foreign %tcflush/errno (tcflush (integer fdes) (integer flag)) 
  266.   no-declare                ; Ultrix
  267.   (to-scheme integer errno_or_false))
  268.  
  269.  
  270. ;;; Stopping and starting I/O (tcflow)
  271. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  272. ;;; Note that the magic %tcflow/foo constants must be defined before this
  273. ;;; file is loaded due to the definitions below.
  274.  
  275. (define (make-flow-controller action)
  276.   (lambda (fdport)
  277.     (call/fdes fdport (lambda (fdes) (%tcflow fdes action)))))
  278.  
  279. (define start-tty-output (make-flow-controller %tcflow/start-out))
  280. (define stop-tty-output  (make-flow-controller %tcflow/stop-out))
  281. (define start-tty-input  (make-flow-controller %tcflow/start-in))
  282. (define stop-tty-input   (make-flow-controller %tcflow/stop-in))
  283.  
  284. (define-errno-syscall (%tcflow fdes action) %tcflow/errno)
  285.  
  286. (define-foreign %tcflow/errno
  287.   (tcflow (integer fdes) (integer action)) no-declare ; Ultrix
  288.   (to-scheme integer errno_or_false))
  289.  
  290.  
  291. ;;; Baud rate translation
  292. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  293. ;;; We should just move these guys out to the tty-consts file.
  294. ;;; We currently search a vector of (code . speed) pairs.
  295.  
  296. (define (encode-baud-rate speed)    ; 9600 -> value of BAUD/9600
  297.   (do ((i (- (vector-length baud-rates) 1) (- i 1)))
  298.       ((eqv? (cdr (vector-ref baud-rates i)) speed)
  299.        (car (vector-ref baud-rates i)))
  300.     (if (< i 0) (error "Unknown baud rate." speed))))
  301.  
  302. (define (decode-baud-rate code)        ; BAUD/9600 -> 9600
  303.   (do ((i (- (vector-length baud-rates) 1) (- i 1)))
  304.       ((eqv? (car (vector-ref baud-rates i)) code)
  305.        (cdr (vector-ref baud-rates i)))
  306.     (if (< i 0) (error "Unknown baud rate code." code))))
  307.  
  308.  
  309. ;;; Set/Get tty process group
  310. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  311.  
  312. (define (set-tty-process-group port/fd proc-group)
  313.   (call/fdes port/fd
  314.     (lambda (fd)
  315.       (%set-tty-process-group fd (if (integer? proc-group)
  316.                      proc-group
  317.                      (proc:pid proc-group))))))
  318.  
  319. (define-simple-errno-syscall (%set-tty-process-group fdes pid)
  320.   %set-tty-process-group/errno)
  321.  
  322. (define-foreign %set-tty-process-group/errno (tcsetpgrp (fixnum fdes)
  323.                                 (pid_t pid))
  324.   no-declare                ; Ultrix
  325.   (to-scheme integer errno_or_false))
  326.  
  327. (define (tty-process-group port/fd)
  328.   (call/fdes port/fd %tty-process-group))
  329.  
  330. (define-errno-syscall (%tty-process-group fd) %tty-process-group/errno
  331.   pid)
  332.  
  333. (define-foreign %tty-process-group/errno (tcgetpgrp (fixnum fdes))
  334.   no-declare                ; Ultrix
  335.   (multi-rep (to-scheme pid_t errno_or_false)
  336.              pid_t))
  337.  
  338. ;;; (open-control-tty fname [flags])
  339. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  340. ;;; Open a control tty, return a port.
  341. ;;; This procedure is only guaranteed to work when the process doesn't already
  342. ;;; have a control tty -- e.g., right after a (BECOME-PROCESS-LEADER) call.
  343. ;;; This limted functionality is about all we can provide portably across BSD,
  344. ;;; SunOS, and SVR4.
  345.  
  346. (define (open-control-tty ttyname . maybe-flags)
  347.   (let ((flags (optional-arg maybe-flags open/read+write)))
  348.     (receive (errno fd) (open-control-tty/errno ttyname flags)
  349.       (if errno
  350.       (errno-error errno open-control-tty ttyname flags)
  351.  
  352.       (let* ((access (bitwise-and flags open/access-mask))
  353.          (port ((if (or (= access open/read) (= access open/read+write))
  354.                 make-input-fdport
  355.                 make-output-fdport)
  356.             fd)))
  357.         (%install-port fd port)
  358.         port)))))
  359.  
  360. (define-foreign open-control-tty/errno (open_ctty (string ttyname)
  361.                           (fixnum flags))
  362.   (multi-rep (to-scheme integer errno_or_false)
  363.              integer))
  364.  
  365.